Celestin Apprentice 7

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Applications / NIH Image 1.62b11 / src / File2.p < prev next >

Wrap

Text File | 1997-05-13 | 84KB | 3,021 lines

unit File2; {Routines used by NIH Image for printing plus a few additional File Menu routines.} interface uses Types, Memory, QuickDraw, QuickDrawText, Packages, Menus, Events, Fonts, Scrap, ToolUtils, Resources, Errors, Palettes, Printing, StandardFile, Folders, TextUtils, Dialogs, Files, Finder, Script, globals, Utilities, Graphics, Lut, PictUtils, QDOffscreen, Components, ImageCompression, Movies, QuickTimeComponents, Sound, FixMath, GestaltEqu; procedure GetInfo; procedure DoPageSetup; procedure Print (ShowDialog: boolean); procedure SetHalftone; function OpenMacPaint (fname: str255; vnum: integer): boolean; procedure TypeMismatch (fname: str255); function GetTextFile (var name: str255; var RefNum: integer): boolean; procedure InitTextInput (name: str255; RefNum: integer); procedure GetLineFromText (var rLine: RealLine; var count: integer); function ImportTextFile (name: str255; RefNum: integer): boolean; procedure PlotXYZ; procedure SaveSettings; procedure ExportAsText (fname: str255; RefNum: integer); procedure ExportMeasurements (fname: str255; RefNum: integer); function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean; function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean; procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt); procedure GetTiffColorMap (f: integer); function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr; function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer; procedure SaveLUT (fname: str255; RefNum: integer); procedure SaveColorTable (fname: str255; RefNum: integer); procedure ExportCoordinates (fname: str255; RefNum: integer); procedure SaveOutline (fname: str255; RefNum: integer); procedure OpenOutline (fname: str255; RefNum: integer); function CheckIO (err: OSerr): integer; function GetTIFFParameters (name: str255; RefNum: integer; var HasColorMap: boolean): boolean; procedure GetXUnits (UnitsKind: UnitsType); procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: extended); procedure Swap2Bytes (var i: integer); procedure Swap4Bytes (var i: LongInt); function OpenQuickTime (name: str255; fRefNum: integer; UseExistingLUT: boolean): boolean; procedure SaveAsQuickTime (fname: str255; fRefNum: integer); function OpenMovieToolbox:boolean; implementation var gstr: str255; {$PUSH} {$D-} procedure PrintErrCheck; var err: integer; ticks: LongInt; begin err := PrError; if err < 0 then beep; end; procedure DoPageSetup; var result: boolean; begin PrOpen; if PrintRecord = nil then begin PrintRecord := THPrint(NewHandle(SizeOF(TPrint))); PrintDefault(PrintRecord); end; if PrError = NoErr then begin result := PrValidate(PrintRecord); result := PrStlDialog(PrintRecord); end; PrClose; end; procedure PrintHalftone; const PostScriptBegin = 190; PostScriptEnd = 191; PostScriptHandle = 192; TextIsPostScript = 194; var HexBufH: handle; hloc, vloc, HexCount, iheight, iwidth, hstart, vstart: integer; Height, Width, eofStr, angle, freq: str255; aLine: LineType; HexBuf: packed array[0..4200] of char; err: OSErr; table: LookupTable; procedure PutHEX (byt: integer); var i, LowByte, HighByte, tmp: integer; h: char; begin if not info^.IdentityFunction then byt := table[byt]; byt := 255 - byt; LowByte := byt mod 16; byt := byt div 16; HighByte := byt mod 16; for i := 1 to 2 do begin if i = 1 then tmp := HighByte else tmp := LowByte; case tmp of 0: h := '0'; 1: h := '1'; 2: h := '2'; 3: h := '3'; 4: h := '4'; 5: h := '5'; 6: h := '6'; 7: h := '7'; 8: h := '8'; 9: h := '9'; 10: h := 'a'; 11: h := 'b'; 12: h := 'c'; 13: h := 'd'; 14: h := 'e'; 15: h := 'f'; end; hexbuf[HexCount] := h; HexCount := HexCount + 1; if HexCount mod 80 = 0 then begin HexBuf[HexCount] := cr; HexCount := HexCount + 1 end; end; end; begin with info^ do begin if not IdentityFunction then GetLookupTable(table); MoveTo(-1, -1); LineTo(-1, -1); {Nothing prints without this dummy dot!} PicComment(PostScriptBegin, 0, nil); {See Tech Note #91} PicComment(TextIsPostScript, 0, nil); NumToString(HalftoneFrequency, freq); NumToString(HalftoneAngle, angle); if HalftoneDotFunction then DrawString(concat(freq, ' ', angle, ' {dup mul exch dup mul add 1 exch sub} setscreen')) else DrawString(concat(freq, ' ', angle, ' {pop} setscreen')); DrawString('0 0 translate'); with RoiRect do begin iwidth := right - left; if iwidth > MaxLine then iwidth := MaxLine; iheight := bottom - top; hstart := left; vstart := top; end; NumToString(iwidth, width); NumToString(iheight, height); DrawString(concat(width, ' ', height, ' scale')); DrawString(concat('/PicStr ', width, ' string def')); DrawString(concat(width, ' ', height, ' 8 [', width, ' 0 0 ', height, ' 0 0]')); DrawString('{currentfile PicStr readhexstring pop} image'); for vloc := vstart to vstart + iheight - 1 do begin GetLine(hstart, vloc, iwidth, aline); HexCount := 0; for hloc := 0 to iwidth - 1 do PutHex(aline[hloc]); HexBuf[HexCount] := cr; HexCount := HexCount + 1; err := PtrToHand(@HexBuf, HexBufH, HexCount); if err <> noErr then exit(PrintHalftone); PicComment(PostScriptHandle, HexCount, HexBufH); DisposeHandle(HexBufH); Show2Values(vloc - vstart, iheight); if CommandPeriod then begin beep; eofStr := chr(4); DrawString(eofStr); exit(PrintHalftone) end; end; end; end; procedure PrintTheImage (PageWidth, PageHeight: integer); var PrintRect: rect; Width, Height: integer; procedure ScaleToFitPage; var hscale, vscale, scale: extended; begin hscale := PageWidth / width; vscale := PageHeight / height; if hscale <= vscale then scale := hscale else scale := vscale; width := trunc(scale * width); height := trunc(scale * height); end; procedure CenterOnPage; begin with PrintRect do begin left := 0; top := 0; if width < PageWidth then left := (PageWidth - width) div 2; if height < PageHeight then top := (Pageheight - height) div 2; right := left + width; bottom := top + height; end; end; begin if isLaserWriter and (not DriverHalftoning) then PrintHalftone else with info^ do begin LoadLUT(cTable); hlock(handle(osPort^.portPixMap)); with RoiRect do begin width := right - left; height := bottom - top; end; if (width > PageWidth) or (height > PageHeight) then ScaleToFitPage; CenterOnPage; if BitAnd(qd.thePort^.portBits.rowBytes, $8000) = $8000 then begin {Assume driver understands Color QD} CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPtr(qd.thePort)^.PortPixMap)^^, RoiRect, PrintRect, SrcCopy, nil); end else CopyBits(BitMapHandle(osPort^.portPixMap)^^, qd.thePort^.PortBits, RoiRect, PrintRect, SrcCopy, nil); end; end; procedure PrintTextBuffer (PageHeight: integer; var PrintPort: TPPrPort); const LineInc = 13; var vloc, i, LineCount, CharCount, LinesPerPage, MaxCount: integer; aLine: str255; begin ClipTextInBuffer := false; LinesPerPage := PageHeight div LineInc; vloc := LineInc; LineCount := 0; CharCount := 0; TextFont(Monaco); TextSize(9); if WhatToPrint = PrintText then MaxCount := 85 else MaxCount := 255; i := 1; repeat CharCount := 0; while (TextBufP^[i] <> cr) and (CharCount < MaxCount) and (i <= TextBufSize) do begin CharCount := CharCount + 1; aLine[CharCount] := TextBufP^[i]; i := i + 1; end; if TextBufP^[i] = cr then i := i + 1 else if CharCount = MaxCount then begin while (aLine[CharCount] <> ' ') and (CharCount > (MaxCount - 15)) do begin CharCount := CharCount - 1; i := i - 1; end; if TextBufP^[i] = ' ' then i := i + 1; end; aLine[0] := chr(CharCount); MoveTo(0, vloc); DrawString(aLine); vLoc := vLoc + LineInc; LineCount := LineCount + 1; if LineCount >= LinesPerPage then begin LineCount := 0; if i < TextBufSize then begin PrClosePage(PrintPort); PrintErrCheck; PrOpenPage(PrintPort, nil); vloc := LineInc end; end; until i > TextBufSize; end; procedure DoPrintText (PageHeight: integer; var PrintPort: TPPrPort); var ByteCount: LongInt; begin if TextInfo <> nil then with TextInfo^.TextTE^^ do begin ByteCount := TELength; BlockMove(hText^, ptr(TextBufP), ByteCount); TextBufSize := ByteCount; PrintTextBuffer(PageHeight, PrintPort); end; end; procedure Print (ShowDialog: boolean); var err, i, LinesToPrint: Integer; tPort: GrafPtr; PrintPort: TPPrPort; PrintStatusRec: TPrStatus; prect: rect; result: boolean; begin if WhatToPrint = PrintImage then SelectAll(false); if (WhatToPrint = PrintImage) or (WhatToPrint = PrintSelection) then begin if OpPending then KillRoi; with info^.RoiRect do LinesToPrint := bottom - top; if not DriverHalftoning then begin DrawLabels('Line:', 'Total:', ''); Show2Values(0, LinesToPrint); end; end; GetPort(tPort); PrOpen; if PrintRecord = nil then begin PrintRecord := THPrint(NewHandle(SizeOF(TPrint))); PrintDefault(PrintRecord); end; if PrError = NoErr then begin InitCursor; result := PrValidate(PrintRecord); isLaserWriter := BSR(PrintRecord^^.prStl.wDev, 8) = 3; prect := PrintRecord^^.prInfo.rPage; if ShowDialog then result := PrJobDialog(PrintRecord) else result := true; if not DriverHalftoning then ShowMessage(CmdPeriodToStop); ShowWatch; if result then for i := 1 to PrintRecord^^.PrJob.icopies do begin PrintPort := PrOpenDoc(PrintRecord, nil, nil); PrintErrCheck; Printing := true; PrOpenPage(PrintPort, nil); if PrError = NoErr then case WhatToPrint of PrintImage, PrintSelection: PrintTheImage(prect.right, prect.bottom); PrintMeasurements: begin CopyResultsToBuffer(1, mCount, true); PrintTextBuffer(prect.Bottom, PrintPort); UnsavedResults := false; end; PrintPlot: DrawPlot; PrintHistogram: DrawHistogram; PrintText: DoPrintText(prect.Bottom, PrintPort); end; Printing := false; PrClosePage(PrintPort); PrintErrCheck; PrCloseDoc(PrintPort); PrintErrCheck; if PrintRecord^^.prJob.bJDocLoop = bSpoolLoop then PrPicFile(PrintRecord, nil, nil, nil, PrintStatusRec); end; end; PrClose; SetPort(tPort); if WhatToPrint = PrintImage then KillRoi; ShowMessage(' '); end; procedure SetHalftone; const FrequencyID = 8; AngleID = 10; DotID = 4; LineID = 5; CustomID = 13; var mylog: DialogPtr; item, i, ignore, SaveFrequency, SaveAngle: integer; SaveFunction, SaveCustom: boolean; str: str255; begin SaveFrequency := HalftoneFrequency; SaveAngle := HalftoneAngle; SaveFunction := HalftoneDotFunction; SaveCustom := DriverHalftoning; mylog := GetNewDialog(30, nil, pointer(-1)); SetDNum(MyLog, FrequencyID, HalftoneFrequency); SelectdialogItemText(MyLog, FrequencyID, 0, 32767); SetDNum(MyLog, AngleID, HalftoneAngle); SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); OutlineButton(MyLog, ok, 16); if HalftoneDotFunction then SetDlogItem(mylog, DotID, 1) else SetDlogItem(mylog, LineID, 1); repeat ModalDialog(nil, item); if item = FrequencyID then begin HalftoneFrequency := GetDNum(MyLog, FrequencyID); DriverHalftoning := false; SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); end; if item = AngleID then begin HalftoneAngle := GetDNum(MyLog, AngleID); if (HalftoneAngle < 0) or (HalftoneAngle > 180) then begin beep; HalftoneAngle := SaveAngle; end; DriverHalftoning := false; SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); end; if (item >= DotID) and (item <= LineID) then begin for i := DotID to LineID do SetDlogItem(mylog, i, 0); SetDlogItem(mylog, item, 1); HalftoneDotFunction := item = DotID; DriverHalftoning := false; SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); end; if item = CustomID then begin DriverHalftoning := not DriverHalftoning; SetDlogItem(mylog, CustomID, ord(not DriverHalftoning)); end; until (item = ok) or (item = cancel); DisposeDialog(mylog); if item = cancel then begin HalftoneFrequency := SaveFrequency; HalftoneAngle := SaveAngle; HalftoneDotFunction := SaveFunction; DriverHalftoning := SaveCustom; end; end; {$POP} procedure GetFileInfo (name: str255; vnum: integer; var DateCreated, LastModified: str255); var FileParmBlock: CInfoPBRec; theErr: OSErr; DateVar, TimeVar: str255; Secs: LongInt; begin DateCreated := ''; with FileParmBlock do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := vnum; ioFVersNum := 0; ioFDirIndex := 0; theErr := PBGetCatInfoSync(@FileParmBlock); {ppc-bug} if theErr = NoErr then begin Secs := ioFlCrDat; IUDateString(Secs, abbrevDate, DateVar); IUTimeString(Secs, true, TimeVar); DateCreated := concat(DateVar, ' ', TimeVar); Secs := ioFlMDDat; IUDateString(Secs, abbrevDate, DateVar); IUTimeString(Secs, true, TimeVar); LastModified := concat(DateVar, ' ', TimeVar); end; end; end; procedure GetVolumnInfo (vnum: integer; var VolumnName: str255; var FreeSpace: LongInt); var theErr: OSErr; str: str255; VolParmBlock: ParamBlockRec; begin VolumnName := ''; with VolParmBlock do begin str := ''; ioVRefNum := vnum; ioNamePtr := @str; ioCompletion := nil; ioVolIndex := -1; theErr := PBGetVInfoSync(@VolParmBlock); {ppc-bug} VolumnName := ioNamePtr^; FreeSpace := ioVAlBlkSiz * ioVFrBlk; end; end; function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; var err: OSErr; f: integer; VolumnName: str255; FreeSpace, ExistingFileSize, NeededSize: LongInt; begin with info^ do begin ExistingFileSize := 0; RoomForFile := true; err := fsopen(fname, RefNum, f); if err = 0 then begin err := GetEOF(f, ExistingFileSize); err := fsClose(f); end; if ExistingFileSize <> 0 then begin if SavingSelection then begin NeededSize := sLines; NeededSize := NeededSize * sPixelsPerLine end else NeededSize := ImageSize; if StackInfo <> nil then with StackInfo^ do NeededSize := NeededSize * nSlices + nSlices * SizeOf(StackIFDType); GetVolumnInfo(RefNum, VolumnName, FreeSpace); if (NeededSize - ExistingFileSize + 8192) > FreeSpace then begin PutError('There is not enough free space on this disk to save this image.'); RoomForFile := false; end; end; end; end; procedure GetInfo; var name, str, DateCreated, LastModified, VolumnName, str2: str255; hloc, vloc, InfoWidth, InfoHeight: integer; SaveRoiShowing: boolean; FreeSpace, DataSize: LongInt; SaveForeIndex, SaveBackIndex: integer; ImageInfo, InfoWindowInfo: InfoPtr; x1, y1, x2, y2, ulength, clength: extended; SaveGDevice: GDHandle; procedure NewLine; begin vloc := vloc + 13; MoveTo(hloc, vloc); end; procedure NewParagraph; begin vloc := vloc + 18; MoveTo(hloc, vloc); end; begin InfoWidth := 260; InfoHeight := 260; with info^ do begin if RoiShowing then InfoHeight := InfoHeight + 50; if RoiShowing and (RoiType = LineRoi) then InfoHeight := InfoHeight + 20; if vref <> 0 then InfoHeight := InfoHeight + 60; name := concat('Info About ', title); SaveRoiShowing := RoiShowing; end; SaveForeIndex := ForegroundIndex; SaveBackIndex := BackgroundIndex; SetForegroundColor(BlackIndex); SetBackgroundColor(WhiteIndex); ImageInfo := info; if NewPicWindow(name, InfoWidth, InfoHeight) then with ImageInfo^ do begin InfoWindowInfo := Info; SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(info^.osPort)); TextFont(Geneva); TextSize(9); hloc := 15; vloc := 10; NewLine; DrawBString('Name: '); DrawString(title); NewParagraph; DrawBString('Width: '); DrawXDimension(PixelsPerLine, 0); NewLine; DrawBString('Height: '); DrawYDimension(nlines, 0); if StackInfo <> nil then begin NewLine; DrawBString('Depth: '); DrawLong(StackInfo^.nSlices); end; NewLine; DrawBString('Size: '); if StackInfo <> nil then DataSize := PixMapSize * StackInfo^.nSlices else if DataH <> nil then DataSize := PixMapSize + PixMapSize * SizeOf(real) else DataSize := PixMapSize; DrawLong((DataSize + 511) div 1024); DrawString('K'); NewParagraph; GetFileInfo(title, vref, DateCreated, LastModified); {DateCreated:='';} if DateCreated <> '' then begin DrawBString('Creation Date: '); DrawString(DateCreated); NewLine; DrawBString('Last Modified: '); DrawString(LastModified); NewLine; end; if fileVersion > 0 then begin DrawBString('Version: '); DrawString('Created by NIH Image '); DrawReal(fileVersion / 100.0, 1, 2); NewParagraph; end; DrawBString('Type: '); if StackInfo <> nil then case StackInfo^.StackType of VolumeStack, MovieStack: str := concat('Stack (', long2str(StackInfo^.nSlices), ' slices)'); rgbStack: str := 'RGB color stack'; else ; end else begin case PictureType of NewPicture: str := 'New'; Normal: str := 'Normal'; PictFile: str := 'PICT'; TiffFile: str := 'TIFF'; Leftover: str := 'Left Over'; Imported: begin if DataType = EightBits then str := 'Imported 8-bit image' else str := 'Imported 16-bit image'; end; FrameGrabberType: str := 'Camera'; BlankField: str := 'Blank Field'; otherwise ; end; if BinaryPic then str := concat(str, ' (Binary)'); end; DrawString(str); if StackInfo <> nil then with StackInfo^ do if SliceSpacing <> 0.0 then begin NewLine; DrawBString('Slice Spacing: '); if SpatiallyCalibrated then DrawString(StringOf(SliceSpacing / xScale:1:2, ' ', xunit, ' (', SliceSpacing:1:2, ' pixels)')) else DrawString(StringOf(SliceSpacing:1:2, ' pixels')); end; NewLine; DrawBString('Lookup Table: '); case LutMode of PseudoColor: str := concat('Pseudocolor (', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')'); GrayScale: str := concat('Grayscale (', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')'); ColorLut: str := 'Color'; CustomGrayscale: str := 'Custom Grayscale'; otherwise end; DrawString(str); NewLine; DrawBString('Magnification: '); if ScaleToFitWindow then begin DrawReal(magnification, 1, 2); DrawString(' (Scale to Window Mode)') end else begin DrawReal(magnification, 1, 0); DrawString(':1') end; NewLine; DrawBString('Scale: '); if SpatiallyCalibrated then begin DrawReal(xScale, 1, 3); DrawString(' pixels per '); DrawString(xUnit); if PixelAspectRatio <> 1.0 then begin NewLine; DrawBString('Pixel Aspect Ratio: '); DrawReal(PixelAspectRatio, 1, 4); end; end else DrawString('None'); if fit <> uncalibrated then begin NewLine; DrawBString('Unit of Measure: '); if UnitOfMEasure = '' then DrawString('None') else DrawString(UnitOfMeasure) end; NewParagraph; DrawBString('Free RAM: '); DrawLong(FreeMem div 1024); DrawString('K'); NewLine; DrawBString('Largest Free Block: '); DrawLong(MaxBlock div 1024); DrawString('K'); if FrameGrabber <> NoFrameGrabber then begin NewLine; DrawBString('Frame Grabber: '); case FrameGrabber of QuickCapture: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Data Translation QuickCapture'); end; ScionLG3: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Scion LG-3 ('); DrawLong(MaxLG3Frames div 2); DrawString(' MB)'); end; ScionAG5: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Scion AG-5'); end; ScionVG5f: begin if fgWidth = 768 then DrawString('50Hz') else DrawString('60Hz'); DrawString(' Scion VG-5'); end QTvdig: DrawString('QuickTime Video Digitizer'); end; end; NewParagraph; if RoiType <> NoRoi then begin DrawBString('Selection Type: '); case RoiType of PolygonRoi: DrawString('Polygon'); FreehandRoi: DrawString('Freehand'); RectRoi: DrawString('Rectangle'); OvalRoi: DrawString('Oval'); LineRoi: DrawString('Straight Line'); FreeLineRoi: DrawString('Freehand Line'); SegLineRoi: DrawString('Segmented Line'); TracedRoi: DrawString('Traced'); end; NewLine; case RoiType of PolygonRoi, FreehandRoi, RectRoi, OvalRoi, TracedRoi: with RoiRect do begin DrawBString(' Left: '); DrawXDimension(left, 0); NewLine; DrawBString(' Top: '); if InvertYCoordinates then DrawYDimension(PicRect.bottom - top - 1, 0) else DrawYDimension(top, 0); NewLine; DrawBString(' Width: '); DrawXDimension(right - left, 0); NewLine; DrawBString(' Height: '); DrawYDimension(bottom - top, 0); end; LineRoi: begin info := ImageInfo; GetLengthOrPerimeter(ulength, clength); GetLoi(x1, y1, x2, y2); Info := InfoWindowInfo; DrawBString(' Length: '); if SpatiallyCalibrated then begin DrawReal(cLength, 1, 2); DrawString(xUnit); end else DrawReal(uLength, 1, 2); NewLine; DrawBString(' Angle: '); DrawReal(LAngle, 1, 2); DrawString('°'); NewLine; DrawBString(' X1: '); DrawXDimension(x1, 2); NewLine; DrawBString(' Y1: '); if InvertYCoordinates then DrawYDimension(PicRect.bottom - y1 - 1, 2) else DrawYDimension(y1, 2); NewLine; DrawBString(' X2: '); DrawXDimension(x2, 2); NewLine; DrawBString(' Y2: '); if InvertYCoordinates then DrawYDimension(PicRect.bottom - y2 - 1, 2) else DrawYDimension(y2, 2); end; FreeLineRoi, SegLineRoi: begin info := ImageInfo; GetLengthOrPerimeter(ulength, clength); Info := InfoWindowInfo; DrawBString(' Length: '); if SpatiallyCalibrated then begin DrawReal(cLength, 1, 2); DrawString(xUnit); end else DrawReal(uLength, 1, 2); NewLine; end; otherwise end; {case} end else DrawBString('No Selection'); SetGDevice(SaveGDevice); end; {with ImageInfo^} SetForegroundColor(SaveForeIndex); SetBackgroundColor(SaveBackIndex); end; function CheckIO (err: OSerr): integer; var ErrStr, Message: str255; ignore: integer; SaveGDevice: GDHandle; begin if err <> 0 then begin case err of -34: Message := 'Disk Full'; -35: Message := 'No such volume'; -36: Message := 'I/O Error'; -39: Message := 'End of file error'; -49: Message := 'File in Use'; -61: Message := 'Write Permission Error'; -120: Message := 'Folder not found' otherwise Message := ''; end; SaveGDevice := GetGDevice; SetGDevice(GetMainDevice); NumToString(err, ErrStr); ParamText(Message, ErrStr, '', ''); InitCursor; ignore := alert(IOErrorID, nil); SetGDevice(SaveGDevice); AbortMacro; end; CheckIO := err; end; function OpenMacPaint (fname: str255; vnum: integer): boolean; const MaxUnPackedSize = 51840; {Max MacPaint size in bytes=720 lines * 72 bytes/line } type mpLine = array[1..18] of LongInt; mpArrayT = array[1..720] of mpLine; mpArrayP = ^mpArrayT; var i, f, ScanLine, LastLine, LastWord, LastColumn: integer; err: osErr; srcSize: LongInt; srcPtr, dstPtr, src, dst: ptr; theBitMap: BitMap; mpArray: mpArrayP; BlankLine, BlankColumn: boolean; frect: rect; SaveGDevice: GDHandle; procedure abort; begin beep; if srcPtr <> nil then DisposePtr(srcPtr); if dstPtr <> nil then DisposePtr(dstPtr); {exit(OpenMacPaint);} {ppc-bug} end; begin OpenMacPaint := false; err := fsOpen(fname, vnum, f); if CheckIO(err) <> noErr then exit(OpenMacPaint); err := GetEOF(f, srcSize); srcSize := srcSize - 512; srcPtr := NewPtr(srcSize); if srcPtr = nil then begin abort; exit(OpenMacPaint); end; err := SetFPos(f, fsFromStart, 512); err := fsRead(f, srcSize, srcPtr); if CheckIO(err) <> noErr then exit(OpenMacPaint); err := fsClose(f); dstPtr := NewPtrClear(MaxUnPackedSize); if dstPtr = nil then begin abort; exit(OpenMacPaint); end; src := srcPtr; dst := dstPtr; for scanLine := 1 to 720 do UnPackBits(src, dst, 72); {bumps both ptrs} DisposePtr(srcPtr); mpArray := mpArrayP(dstPtr); LastLine := 720; BlankLine := true; repeat for i := 1 to 18 do blankLine := BlankLine and (mpArray^[LastLine, i] = 0); if BlankLine then LastLine := LastLine - 1; until (not BlankLine) or (LastLine = 1); LastWord := 18; BlankColumn := true; repeat for i := 1 to LastLine do blankColumn := BlankColumn and (mpArray^[i, LastWord] = 0); if BlankColumn then LastWord := LastWord - 1; until (not BlankColumn) or (LastWord = 1); LastColumn := LastWord * 32; LastColumn := LastColumn + 8; if LastColumn > 576 then LastColumn := 576; LastLine := LastLine + 8; if LastLine > 720 then LastLine := 720; SetRect(frect, 0, 0, LastColumn, LastLine); with theBitMap do begin baseAddr := dstPtr; rowBytes := 72; bounds := frect; end; if not NewPicWindow(fname, LastColumn, LastLine) then begin abort; exit(OpenMacPaint); end; SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetForegroundColor(BlackIndex); SetBackgroundColor(WhiteIndex); with info^ do begin CopyBits(theBitMap, BitMapHandle(osPort^.PortPixMap)^^, frect, frect, SrcCopy, nil); DisposePtr(dstPtr); PictureType := imported; BinaryPic := true; SetGDevice(SaveGDevice); if PixMapSize > UndoBufSize then PutWarning; end; OpenMacPaint := true; end; procedure TypeMismatch (fname: str255); begin PutError(concat('The file "', fname, '" is a different type, and therefore cannot be replaced')); end; function GetTextFile (var name: str255; var RefNum: integer): boolean; var where: Point; typeList: SFTypeList; reply: SFReply; err: OSErr; pBlock: WDPBRec; begin where.v := 120; where.h := 120; typeList[0] := 'TEXT'; SFGetFile(Where, '', nil, 1, @typeList, nil, reply); if reply.good then with reply do begin name := fname; RefNum := vRefNum; GetTextFile := true; end else GetTextFile := false; end; procedure GetBuffer; var err: OSErr; count, FilePos: LongInt; begin count := MaxTextBufSize; err := fsread(Textf, count, ptr(TextBufP)); TextBufSize := count; err := GetFPos(Textf, FilePos); if FilePos = TextFileSize then begin TextBufSize := TextBufSize + 1; if TextBufSize > MaxTextBufSize then TextBufSize := MaxTextBufSize; TextBufP^[TextBufSize] := eofChr; err := fsclose(Textf); end; TextIndex := 1; end; function GetByte: char; begin GetByte := TextBufP^[TextIndex]; TextIndex := TextIndex + 1; if TextIndex > MaxTextBufSize then GetBuffer; end; function GetNumber: extended; var c: char; str: str255; begin repeat c := GetByte; if c = tab then begin GetNumber := 0.0; {Assume 0 zero for missing value.} exit(GetNumber); end; if (c = cr) or (c = eofChr) then begin TextEol := true; TextEof := c = eofChr; GetNumber := NoValue; exit(GetNumber); end; until c in ['0'..'9', '-', '.']; Str := ''; while c in ['0'..'9', '+', '-', '.', 'e', 'E'] do begin Str := concat(str, c); c := GetByte; if (c = cr) or (c = eofChr) then begin TextEol := true; TextEof := c = eofChr; end; end; GetNumber := StringToReal(str); end; procedure GetLineFromText (var rLine: RealLine; var count: integer); var n: extended; begin count := 0; if TextEof then exit(GetLineFromText); repeat n := GetNumber; if n <> NoValue then begin count := count + 1; rLine[count] := n; end; until TextEol or (count = MaxLine); TextEol := false; end; procedure InitTextInput (name: str255; RefNum: integer); var err: OSErr; begin err := FSOpen(name, RefNum, Textf); err := GetEof(Textf, TextFileSize); err := SetFPos(Textf, fsFromStart, 0); ShowWatch; if WhatsOnClip = TextOnClip then WhatsOnClip := NothingOnClip; GetBuffer; TextEol := false; TextEof := false; end; function ImportTextFile (name: str255; RefNum: integer): boolean; var nRows, nColumns, count, i, vloc, BlankPixel, nPixelsPerLine: integer; rLine: RealLine; pvalue: extended; min, max, ScaleFactor, DefaultValue, tvalue: extended; err: OSErr; line, BlankLine: LineType; TheInfo: FInfo; noScaling:boolean; begin ImportTextFile := false; err := GetFInfo(name, RefNum, TheInfo); if TheInfo.fdType <> 'TEXT' then begin PutError('File is not of type ''TEXT''.'); exit(ImportTextFile); end; InitTextInput(name, RefNum); nRows := 0; nColumns := 0; max := -10e-10; min := 10e10; ShowMessage(concat('First pass used to find ', crStr, 'width, height,min, and max.', crStr, crStr, CmdPeriodToStop)); DrawLabels('Line:', '', ''); while not TextEof do begin GetLineFromText(rLine, count); if not (TextEof and (count = 0)) then nRows := nRows + 1; if count > nColumns then nColumns := count; for i := 1 to count do begin pvalue := rLine[i]; if pvalue > max then max := pvalue; if pvalue < min then min := pvalue; end; if nRows mod 10 = 0 then begin Show1Value(nRows, NoValue); ShowAnimatedWatch; if CommandPeriod then begin beep; err := fsclose(Textf); Exit(ImportTextFile); end; end; end; ShowMessage(concat('rows= ', long2str(nRows), crStr, 'columns= ', long2str(ncolumns), crStr, 'min= ', long2str(round(min)), crStr, 'max= ', long2str(round(max)))); if nColumns > MaxLine then begin PutError(concat('More than ',long2str(MaxLine),' pixels per line.')); Exit(ImportTextFile); end; nPixelsPerLine := nColumns; if NewPicWindow(name, nPixelsPerLine, nrows) then with info^ do begin if (not ImportAutoScale) and (max > min) then begin min := ImportMin; max := ImportMax; end; ScaleFactor := 253.0 / (max - min); InitTextInput(name, RefNum); vloc := 0; DefaultValue := 0.0; if DefaultValue < min then DefaultValue := min; if DefaultValue > max then DefaultValue := max; BlankPixel := round((DefaultValue - min) * ScaleFactor + 1); for i := 0 to nColumns - 1 do BlankLine[i] := BlankPixel; NoScaling:=not ImportAutoScale and ((min=0) and (max=255)); DrawLabels('Line:', 'Total:', ''); while not TextEof do begin GetLineFromText(rLine, count); if not (TextEof and (count = 0)) then begin line := BlankLine; if ImportAutoScale then {Map values into the range 1-254} for i := 1 to count do line[i - 1] := round((rLine[i] - min) * ScaleFactor + 1) else for i := 1 to count do begin tvalue := rLine[i]; if tvalue < min then tvalue := min; if tvalue > max then tvalue := max; if noScaling then line[i - 1]:=round(tvalue) else line[i - 1] := round((tvalue - min) * ScaleFactor + 1); end; PutLine(0, vloc, PixelsPerLine, line); vloc := vloc + 1; end; if vloc mod 10 = 0 then begin Show2Values(vloc, nRows); ShowAnimatedWatch; if CommandPeriod then begin beep; err := fsclose(Textf); Exit(ImportTextFile); end; end; end; if noScaling then ImportCalibrate:=false else begin fit := StraightLine; nCoefficients := 2; coefficient[2] := (max - min) / 253.0; coefficient[1] := min - coefficient[2]; nKnownValues := 0; UpdateTitleBar; if macro then GenerateValues; ZeroClip := false; end; changes := true; PictureType := imported; end; {with} ImportTextFile := true; end; procedure PlotXYZ; {Reads X-Y coordinate pairs and optional intensiy(Z) values from a} {two or three column tab-delimited text file and plots them in the current window.} var fname, str: str255; RefNum, i, nColumns, nValues, index, wheight: integer; rLine: RealLine; begin RefNum := 0; if not GetTextFile(fname, RefNum) then exit(PlotXYZ); InitTextInput(fname, RefNum); GetLineFromText(rLine, nValues); nColumns := nValues; if not ((nColumns = 2) or (nColumns = 3)) then begin PutError('File must have two or three columns.'); exit(PlotXYZ); end; wheight := info^.nLines; index := ForegroundIndex; repeat if nColumns = 3 then begin index := round(rLine[3]); if index > 255 then index := 255; if index < 0 then index := 0; end; PutPixel(round(rLine[1]), wheight - round(rLine[2] + 1), index); GetLineFromText(rLine, nValues); until nValues = 0; InitCursor; end; procedure SaveSettings; var TheInfo: FInfo; ByteCount: LongInt; f, i: integer; err: OSErr; settings: SettingsType; PrefsVRef: integer; PrefsDirID: LongInt; PrefsSpec: FSSpec; PrefsError:boolean; begin with settings, info^ do begin sID := 'IMAG'; sVersion := version; sForegroundIndex := ForegroundIndex; sBackgroundIndex := BackgroundIndex; sBrushHeight := BrushHeight; sBrushWidth := BrushWidth; sSprayCanDiameter := SprayCanDiameter; sLUTMode := LUTMode; sOldColorStart := 30; sOldColorWidth := 10; sCurrentFontID := CurrentFontID; sCurrentStyle := CurrentStyle; sCurrentSize := CurrentSize; sTextJust := TextJust; sTextBack := TextBack; sNExtraColors := nExtraColors; sExtraColors := ExtraColors; sInvertVideo := InvertVideo; sMeasurements := Measurements; sInvertPlots := InvertPlots; sAutoScalePlots := AutoScalePlots; sLinePlot := LinePlot; sDrawPlotLabels := DrawPlotLabels; for i := 1 to 12 do sUnused1[i] := 0; sFixedSizePlot := FixedSizePlot; sProfilePlotWidth := ProfilePlotWidth; sProfilePlotHeight := ProfilePlotHeight; sFramesToAverage := FramesToAverage; sNewPicWidth := NewPicWidth; sNewPicHeight := NewPicHeight; sBufferSize := BufferSize; sThresholdToForeground := ThresholdToForeground; sNonThresholdToBackground := NonThresholdToBackground; sVideoChannel := VideoChannel; sWhatToImport := WhatToImport; sImportCustomWidth := ImportCustomWidth; sImportCustomHeight := ImportCustomHeight; sImportCustomOffset := ImportCustomOffset; sWandAutoMeasure := WandAutoMeasure; sWandAdjustAreas := WandAdjustAreas; sBinaryIterations := BinaryIterations; sScaleArithmetic := ScaleArithmetic; sInvertPixelValues := InvertPixelValues; sInvertYCoordinates := InvertYCoordinates; sFieldWidth := FieldWidth; sPrecision := precision; sMinParticleSize := MinParticleSize; sMaxParticleSize := MaxParticleSize; sIgnoreParticlesTouchingEdge := IgnoreParticlesTouchingEdge; sLabelParticles := LabelParticles; sOutlineParticles := OutlineParticles; sIncludeHoles := IncludeHoles; sOscillatingMovies := OscillatingMovies; sDriverHalftoning := DriverHalftoning; sMaxMeasurements := MaxMeasurements; sImportCustomDepth := ImportCustomDepth; sImportSwapBytes := ImportSwapBytes; sImportCalibrate := ImportCalibrate; sImportAutoscale := ImportAutoscale; for i := 1 to 12 do sUnused2[i] := 0; sShowHeadings := ShowHeadings; sDefaultVRefNum := 0; sDefaultDirID := 0; sKernelsVRefNum := 0; sKernelsDirID := 0; {***} sProfilePlotMin := ProfilePlotMin; sProfilePlotMax := ProfilePlotMax; sImportMin := ImportMin; sImportMax := ImportMax; sHighlightPixels := HighlightSaturatedPixels; {***} sBallRadius := BallRadius; sFasterBackgroundSubtraction := FasterBackgroundSubtraction; sScaleConvolutions := ScaleConvolutions; {V1.42} sBinaryCount := BinaryCount; sColorTable := ColorTable; sColorStart := ColorStart; sColorEnd := ColorEnd; sInvertedTable := InvertedColorTable; {V1.44} sHalftoneFrequency := HalftoneFrequency; sHalftoneAngle := HalftoneAngle; sHalftoneDotFunction := HalftoneDotFunction; sDacLow := DacLow; sDacHigh := DacHigh; sSyncMode := SyncMode; sSwitchLUTOnSuspend := SwitchLUTOnSuspend; sVideoRateAveraging := VideoRateAveraging; sImportInvert := ImportInvert; sTextCreator := TextCreator; sMathSubGain:=MathSubGain; sMathSubOffset:=round(MathSubOffset); {V1.60} sfgScale := fgScale; sUseBuiltinDigitizer := UseBuiltinDigitizer; sDigitizerMode := DigitizerMode; sDigitizerStandard := DigitizerStandard; sLutFriendlyMode := LutFriendlyMode; for i := 1 to 10 do sUnused[i] := 0; end; {with} if System7 then begin {Save in Preferences folder} PrefsError:=true; err:=FindFolder(kOnSystemDisk, kPreferencesFolderType, kDontCreateFolder, PrefsVRef, PrefsDirID); if err=noErr then err:=FSMakeFSSpec(PrefsVRef, PrefsDirID, PrefsName, PrefsSpec); if err=noErr then err:=FSpDelete(PrefsSpec); if (err=noErr) or (err=fnfErr) then begin err:=FSpCreate(PrefsSpec, 'Imag', 'pref', smSystemScript); if err=noErr then err:=FSpOpenDF(PrefsSpec, fsCurPerm, f); if err=noErr then PrefsError:=false; end; if PrefsError then begin PutError('Error saving settings file'); exit(SaveSettings); end; end else begin {Save in System folder} err := GetFInfo(PrefsName, SystemRefNum, TheInfo); if err = FNFerr then begin err := create(PrefsName, SystemRefNum, 'Imag', 'pref'); if CheckIO(err) <> 0 then exit(SaveSettings); end; err := fsopen(PrefsName, SystemRefNum, f); end; if CheckIO(err) <> 0 then exit(SaveSettings); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(settings); err := fswrite(f, ByteCount, @settings); if CheckIO(err) <> 0 then begin err := fsclose(f); exit(SaveSettings) end; err := SetEof(f, ByteCount); err := fsclose(f); err := FlushVol(nil, SystemRefNum); end; procedure ExportAsText (fname: str255; RefNum: integer); var err, f, width, hloc, vloc: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; AutoSelectAll, InvertValues: boolean; tLine: LineType; begin if info = NoInfo then exit(ExportAsText); err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportAsText) end; FNFerr: begin err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT'); if CheckIO(err) <> 0 then exit(ExportAsText); end; otherwise if CheckIO(err) <> 0 then exit(ExportAsText) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportAsText); AutoSelectAll := not info^.RoiShowing; if AutoSelectAll then SelectAll(true); if TooWide then exit(ExportAsText); FileSize := 0; with info^, info^.RoiRect do begin InvertValues := isInvertingFunction; width := right - left; for vloc := top to bottom - 1 do begin GetLine(left, vloc, width, tLine); TextBufSize := 0; for hloc := 0 to width - 1 do begin if fit = uncalibrated then PutLong(tLine[hloc], 0) else if InvertValues then PutLong(255 - tLine[hloc], 0) else PutString(StringOf(cValue[tLine[hloc]]:1:precision)); if hloc <> (width - 1) then PutTab; end; PutChar(cr); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod then leave; if (vloc mod 10) = 0 then ShowAnimatedWatch; end; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); end; if AutoSelectAll then KillRoi; end; procedure ExportCoordinates (fname: str255; RefNum: integer); var err, f, i, y: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; InvertY: boolean; begin if not CoordinatesAvailableMsg then begin exit(ExportCoordinates) end; err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportCoordinates) end; FNFerr: begin err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT'); if CheckIO(err) <> 0 then exit(ExportCoordinates); end; otherwise if CheckIO(err) <> 0 then exit(ExportCoordinates) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportCoordinates); FileSize := 0; InvertY := InvertYCoordinates and (Info <> NoInfo); with info^ do for i := 1 to nCoordinates do begin TextBufSize := 0; PutLong(xCoordinates^[i] + RoiRect.left, 0); PutTab; y := yCoordinates^[i] + RoiRect.top; if InvertY then y := PicRect.bottom - y - 1; PutLong(y, 0); PutChar(cr); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod then leave; end; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); end; procedure ExportMeasurements (fname: str255; RefNum: integer); const LinesPerPass = 25; var err, f, i, first, last: integer; TheInfo: FInfo; ByteCount, FileSize: LongInt; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(ExportMeasurements) end; FNFerr: begin err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT'); if CheckIO(err) <> 0 then exit(ExportMeasurements); end; otherwise if CheckIO(err) <> 0 then exit(ExportMeasurements) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(ExportMeasurements); FileSize := 0; first := 1; last := LinesPerPass; repeat if last > mCount then last := mCount; CopyResultsToBuffer(first, last, ShowHeadings or OptionKeyWasDown); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); FIleSize := FileSize + ByteCount; if (CheckIO(err) <> 0) or CommandPeriod or (last = mCount) then leave; first := first + LinesPerPass; last := last + LinesPerPass; until false; err := SetEof(f, FileSize); err := fsclose(f); err := FlushVol(nil, RefNum); UnsavedResults := false; end; procedure Swap2Bytes (var i: integer); type atype = packed array[1..2] of char; var a: atype; c: char; begin a := atype(i); c := a[1]; a[1] := a[2]; a[2] := c; i := integer(a) end; procedure Swap4Bytes (var i: LongInt); var a: ostype; c: char; begin a := ostype(i); c := a[1]; a[1] := a[4]; a[4] := c; c := a[2]; a[2] := a[3]; a[3] := c; i := LongInt(a) end; function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean; var TiffHeader: TiffHdr; ByteCount: LongInt; err: OSErr; begin ByteCount := 8; err := SetFPos(f, fsFromStart, 0); err := fsread(f, ByteCount, @TiffHeader); if CheckIO(err) <> NoErr then begin OpenTiffHeader := false; exit(OpenTiffHeader); end; with TiffHeader do begin IntelByteOrder := ByteOrder = 'II'; if (ByteOrder <> 'MM') and (ByteOrder <> 'II') then begin PutError('Invalid TIFF header.'); OpenTiffHeader := false; exit(OpenTiffHeader) end; DirOffset := FirstIFDOffset; if IntelByteOrder then Swap4Bytes(DirOffset); OpenTiffHeader := true; end; end; procedure GetTiffEntry (f: integer; var tag: integer; var N, value: LongInt); var IFDEntry: TiffEntry; ByteCount: LongInt; IntValue: integer; err: OSErr; str: str255; begin ByteCount := 12; err := FSRead(f, ByteCount, @IFDEntry); with IFDEntry do begin tag := TagField; N := length; if IntelByteOrder then begin Swap2Bytes(tag); Swap2Bytes(ftype); Swap4Bytes(N); end; value := offset; if (ftype = short) and (N = 1) then begin value := bsr(value, 16); if IntelByteOrder then begin IntValue := value; Swap2Bytes(IntValue); value := IntValue end end else if IntelByteOrder then Swap4Bytes(value); if OptionKeyWasDown then begin gstr := concat(gstr, long2str(tag), ' ', long2str(ftype), ' ', long2str(N), ' ', long2str(value), crStr); ShowMessage(gstr); end; end; end; function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean; const NoUnit = 1; inch = 2; centimeter = 3; var ByteCount, length, ftype, N, value, BytesPerStrip, SaveFPos: LongInt; err: OSErr; nEntries, i, tag, entry: integer; StripOffsetsArray: array[1..2] of LongInt; xRes, yRes: extended; function GetResolution: extended; var resolution: array[1..2] of LongInt; begin err := GetFPos(f, SaveFPos); err := SetFPos(f, fsFromStart, value); ByteCount := 8; err := fsread(f, ByteCount, @Resolution); if IntelByteOrder then begin Swap4Bytes(Resolution[1]); Swap4Bytes(Resolution[2]); end; err := SetFPos(f, fsFromStart, SaveFPos); if resolution[2] <> 0 then GetResolution := resolution[1] / resolution[2] else GetResolution := 0.0; end; begin if OptionKeyWasDown then gstr := ''; xRes := 0.0; err := SetFPos(f, fsFromStart, DirOffset); ByteCount := 2; err := FSRead(f, ByteCount, @nEntries); if CheckIO(err) <> NoErr then begin OpenTiffDirectory := false; exit(OpenTiffDirectory); end; if IntelByteOrder then Swap2Bytes(nEntries); with TiffInfo do begin width := 0; height := 0; BitsPerPixel := 8; SamplesPerPixel:=1; PlanarConfig := 1; OffsetToData := 0; Resolution := 0.0; ResUnits := tNoUnits; OffsetToColorMap := 0; OffsetToImageHeader := -1; StripOffsetsArray[1] := 0; for entry := 1 to nEntries do begin GetTiffEntry(f, tag, N, value); if tag = 0 then begin PutError('Invalid TIFF format.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; case tag of ImageWidth: width := value; ImageLength: height := value; BitsPerSample: begin if N = 1 then BitsPerPixel := value; if value = 1 then begin PutError('NIH Image cannot open 1-bit TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; if (value = 16) and not importing then begin PutError('Use Import to open 16-bit TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; end; SamplesPerPixelTag: if (value = 1) or (value = 3) then SamplesPerPixel:=value else begin PutError('NIH Image can only open TIFF files with 1 or 3 samples per pixel.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; PlanarConfigTag: PlanarConfig := value; Compression: if value <> 1 then begin PutError('NIH Image cannot open compressed TIFF files.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; PhotoInterp: ZeroIsBlack := value = 1; StripOffsets: if N = 1 then OffsetToData := value else begin err := GetFPos(f, SaveFPos); err := SetFPos(f, fsFromStart, value); ByteCount := 8; err := fsread(f, ByteCount, @StripOffsetsArray); if IntelByteOrder then begin Swap4Bytes(StripOffsetsArray[1]); Swap4Bytes(StripOffsetsArray[2]); end; err := SetFPos(f, fsFromStart, SaveFPos); end; RowsPerStrip: if (OffsetToData=0) and (value < height) then begin BytesPerStrip := value * width; if BitsPerPixel = 16 then BytesPerStrip := BytesPerStrip * 2 else if SamplesPerPixel = 3 then BytesPerStrip := BytesPerStrip * 3; if StripOffsetsArray[1] = 0 then begin PutError('Invalid TIFF directory.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; if StripOffsetsArray[2] <> (StripOffsetsArray[1] + BytesPerStrip) then begin PutError('NIH Image cannot open TIFF files with discontiguous strips.'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; OffsetToData := StripOffsetsArray[1]; end; XResolution: XRes := GetResolution; YResolution: begin yRes := GetResolution; if (xRes = yRes) and (xRes > 0.0) then begin resolution := xRes; ResUnits := tInches; end; end; ResolutionUnit: case value of NoUnit: ResUnits := tNoUnits; Centimeter: ResUnits := tCentimeters; otherwise end; ColorMapTag: if N = 768 then OffsetToColorMap := value; ImageHdrTag: OffsetToImageHeader := value; otherwise end; end; {for} if OffsetToData = 0 then OffsetToData := StripOffsetsArray[1]; ByteCount := 4; err := FSRead(f, ByteCount, @NextIFD); if IntelByteOrder then Swap4Bytes(NextIFD); if OptionKeyWasDown then begin gstr := concat(gstr, 'Next IFD=', long2str(NextIFD)); ShowMessage(gstr); end; if width = 0 then begin PutError('Error opening TIFF directory'); OpenTiffDirectory := false; exit(OpenTiffDirectory) end; end; {with} OpenTiffDirectory := true; end; procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt); var i: integer; err: OSErr; ColorMap: TiffColorMapType; ColorMapSize: LongInt; begin LoadLUT(info^.cTable); if ScreenDepth=8 then begin for i := 0 to 255 do with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin ColorMap[1, i] := red; ColorMap[2, i] := green; ColorMap[3, i] := blue; end; end else begin for i := 0 to 255 do with info^.cTable[i].rgb do begin ColorMap[1, i] := red; ColorMap[2, i] := green; ColorMap[3, i] := blue; end; end; err := SetFPos(f, FSFromStart, HeaderSize + TiffDirSize + ImageDataSize); ColorMapSize := SizeOf(ColorMap); err := fswrite(f, ColorMapSize, @ColorMap); if CheckIO(err) <> 0 then beep; end; procedure GetTiffColorMap (f: integer); var i: integer; ByteCount: LongInt; err: OSErr; ColorMap: TiffColorMapType; begin with info^ do begin ByteCount := SizeOf(ColorMap); err := SetFPos(f, fsFromStart, ColorMapOffset); err := fsRead(f, ByteCount, @ColorMap); if err = NoErr then begin if IntelByteOrder then for i := 0 to 255 do begin Swap2Bytes(ColorMap[1, i]); Swap2Bytes(ColorMap[2, i]); Swap2Bytes(ColorMap[3, i]); end; for i := 0 to 255 do with cTable[i].rgb do begin red := ColorMap[1, i]; green := ColorMap[2, i]; blue := ColorMap[3, i]; end; LoadLUT(cTable); LUTMode := ColorLut; SetupPseudocolor; IdentityFunction := false; if isGrayScaleLUT then begin info^.LutMode := CustomGrayScale; DrawMap; end; end else beep; end;{with} end; function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr; var i: integer; err: OSErr; SavingStack, SavingRGBStack: boolean; ByteCount, width, height: LongInt; TiffInfo1: record Header: TiffHdr; {8} nEntries: integer; {2} TiffDir: array[1..9] of TiffEntry; {108} end; ColorMapEntry: TiffEntry; {12 (Optional)} TiffInfo2: record ImageHdrEntry: TiffEntry; {12} NextIFD: LongInt; {4} BitsPerPixelData: array[1..3] of integer; {6} {only used for RGB files} filler: array[1..TiffFillerSize] of integer; {116} end; BitsPerSampleData: record rBitsPerSample, gBitsPerSample, bBitsPerSample:integer; end; begin with info^ do begin SavingStack := false; SavingRGBStack := false; if StackInfo <> nil then SavingStack := StackInfo^.nSlices > 1; if SavingStack then if (StackInfo^.StackType = rgbStack) and (StackInfo^.nSlices = 3) then begin SavingRGBStack := true; ctabSize := 0; end; if SavingSelection then begin width := sPixelsPerLine; height := sLines end else begin width := PixelsPerLine; height := nLines end; with TiffInfo1 do begin with header do begin ByteOrder := 'MM'; Version := 42; FirstIFDOffset := 8; end; if ctabSize > 0 then nEntries := 11 else nEntries := 10; for i := 1 to 9 do with TiffDir[i] do begin ftype := 3; length := 1 end; with TiffDir[1] do begin TagField := NewSubfileType; ftype := 4; offset := 0; end; with TiffDir[2] do begin TagField := ImageWidth; offset := bsl(width, 16); end; with TiffDir[3] do begin TagField := ImageLength; offset := bsl(height, 16); end; with TiffDir[4] do begin TagField := BitsPerSample; if SavingRGBStack then begin ftype := 3; length := 3; offset := SizeOf(TiffInfo1) + SizeOf(TiffEntry) + SizeOf(LongInt); with TiffInfo2 do for i := 1 to 3 do BitsPerPixelData[i] := 8; end else begin offset := bsl(8, 16); with TiffInfo2 do for i := 1 to 3 do BitsPerPixelData[i] := 0; end; end; with TiffDir[5] do begin TagField := PhotoInterp; if SavingRGBStack then offset := bsl(2, 16) else if ctabSize > 0 then offset := bsl(3, 16) else offset := 0; end; with TiffDir[6] do begin TagField := StripOffsets; ftype := 4; offset := TiffDirSize + HeaderSize; end; with TiffDir[7] do begin TagField := SamplesPerPixelTag; if SavingRGBStack then offset := bsl(3, 16) else offset := bsl(1, 16); end; with TiffDir[8] do begin TagField := RowsPerStrip; offset := bsl(height, 16); end; with TiffDir[9] do begin TagField := StripByteCount; ftype := 4; if SavingRGBStack then offset := width * height * 3 else offset := width * height; end; end; ByteCount := SizeOf(TiffInfo1); err := SetFPos(f, FSFromStart, 0); err := FSWrite(f, ByteCount, @TiffInfo1); if CheckIO(err) <> NoErr then begin SaveTiffDir := err; exit(SaveTiffDir); end; if ctabSize > 0 then with ColorMapEntry do begin TagField := ColorMapTag; ftype := 3; length := 768; offset := HeaderSize + TiffDirSize + ImageDataSize; ByteCount := SizeOf(ColorMapEntry); err := FSWrite(f, ByteCount, @ColorMapEntry); if CheckIO(err) <> NoErr then begin SaveTiffDir := err; exit(SaveTiffDir); end; end; with TiffInfo2 do begin with ImageHdrEntry do begin TagField := ImageHdrTag; ftype := 3; length := 256; offset := TiffDirSize; end; NextIFD := 0; if SavingStack then NextIFD := HeaderSize + TiffDirSize + ImageDataSize + ctabSize; for i := 1 to TiffFillerSize do filler[i] := 0; end; end; {with info^} ByteCount := SizeOf(TiffInfo2); err := FSWrite(f, ByteCount, @TiffInfo2); SaveTiffDir := CheckIO(err); end; function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer; var IFD, entry: integer; StackIFD: StackIFDType; err: OSErr; IFDoffset, SliceOffset, ByteCount: LongInt; begin with info^, StackInfo^, StackIFD do begin IFDoffset := HeaderSize + TiffDirSize + ImageDataSize + ctabSize; err := SetFPos(f, FSFromStart, IFDoffset); SliceOffset := HeaderSize + TiffDirSize + ImageSize; for IFD := 2 to nSlices do {IFD=Image File Directory} begin nEntries := 6; for entry := 1 to nEntries do with TiffDir[entry] do begin ftype := 3; length := 1 end; with TiffDir[1] do begin TagField := NewSubfileType; ftype := 4; offset := 0; end; with TiffDir[2] do begin TagField := ImageWidth; offset := bsl(PixelsPerLine, 16); end; with TiffDir[3] do begin TagField := ImageLength; offset := bsl(nLines, 16); end; with TiffDir[4] do begin TagField := BitsPerSample; offset := bsl(8, 16); end; with TiffDir[5] do begin TagField := PhotoInterp; offset := 0; end; with TiffDir[6] do begin TagField := StripOffsets; ftype := 4; offset := SliceOffset; end; SliceOffset := SliceOffset + ImageSize; IFDoffset := IFDoffset + SizeOf(StackIFD); if IFD <> nSlices then NextIFD := IFDoffset else NextIFD := 0; ByteCount := SizeOf(StackIFD); err := fswrite(f, ByteCount, @StackIFD); if err <> NoErr then begin WriteExtraTiffIFDs := err; exit(WriteExtraTiffIFDs); end; end; {for} end; {with} WriteExtraTiffIFDs := NoErr; end; procedure SaveLUT (fname: str255; RefNum: integer); var err: integer; TheInfo: FInfo; LUT: array[1..3] of packed array[0..255] of byte; i, f: integer; ByteCount: LongInt; tempRGB:rgbColor; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'ICOL' then begin TypeMismatch(fname); exit(SaveLUT) end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'ICOL'); if CheckIO(err) <> 0 then exit(SaveLUT); end; otherwise if CheckIO(err) <> 0 then exit(SaveLUT); end; DisableDensitySlice; LoadLUT(Info^.cTable); if ScreenDepth = 8 then begin for i := 0 to 255 do with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin LUT[1, i] := band(bsr(red, 8), 255); LUT[2, i] := band(bsr(green, 8), 255); LUT[3, i] := band(bsr(blue, 8), 255); end; end else begin for i := 0 to 255 do with info^.cTable[i].rgb do begin LUT[1, i] := band(bsr(red, 8), 255); LUT[2, i] := band(bsr(green, 8), 255); LUT[3, i] := band(bsr(blue, 8), 255); end; end; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveLUT); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(LUT); err := fswrite(f, ByteCount, @LUT); if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, RefNum); exit(SaveLUT) end; err := SetEof(f, ByteCount); err := fsclose(f); err := GetFInfo(fname, RefNum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, RefNum, TheInfo); end; err := FlushVol(nil, RefNum); end; procedure SaveColorTable (fname: str255; RefNum: integer); var err: integer; TheInfo: FInfo; i, f: integer; ByteCount: LongInt; hdr: PaletteHeader; begin with info^ do err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'ICOL' then begin TypeMismatch(fname); exit(SaveColorTable) end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'ICOL'); if CheckIO(err) <> 0 then exit(SaveColorTable); end; otherwise if CheckIO(err) <> 0 then exit(SaveColorTable); end; with info^ do begin InitPaletteHeader(hdr); err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveColorTable); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(PaletteHeader); if ByteCount <> 32 then PutError('Palette header size <> 32.'); err := fswrite(f, ByteCount, @hdr); ByteCount := nColors; err := fswrite(f, ByteCount, @redLUT); ByteCount := nColors; err := fswrite(f, ByteCount, @greenLUT); ByteCount := nColors; err := fswrite(f, ByteCount, @blueLUT); if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, RefNum); exit(SaveColorTable) end; err := SetEOF(f, SizeOf(PaletteHeader) + 3 * nColors); err := fsclose(f); err := GetFInfo(fname, RefNum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, RefNum, TheInfo); end; err := FlushVol(nil, RefNum); end; {with info^} end; procedure SaveOutline (fname: str255; RefNum: integer); var err: integer; TheInfo: FInfo; i, f: integer; ByteCount, DataSize: LongInt; hdr: RoiHeader; SaveCoordinates: boolean; dX1, dY1, dX2, dY2: extended; begin with info^ do begin if not RoiShowing then begin PutError('No outline available to save.'); exit(SaveOutline); end; if (RoiType = FreeLineRoi) or (RoiType = SegLineRoi) then begin PutError('Freehand and segmented line selections cannot be saved.'); exit(SaveOutline); end; SaveCoordinates := (RoiType = PolygonRoi) or (RoiType = FreehandRoi) or (RoiType = TracedRoi); if SaveCoordinates then if not CoordinatesAvailableMsg then begin exit(SaveOutline); end; err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'Iout' then begin TypeMismatch(fname); exit(SaveOutline) end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'Iout'); if CheckIO(err) <> 0 then exit(SaveOutline); end; otherwise if CheckIO(err) <> 0 then exit(SaveOutline); end; with hdr do begin rID := 'Iout'; rVersion := version; rRoiType := RoiType; rRoiRect := RoiRect; rNCoordinates := nCoordinates; GetLoi(dX1, dY1, dX2, dY2); rX1:=dX1; rY1:=dY1; rX2:=dX2; rY2:=dY2; rLineWidth := LineWidth; for i := 1 to 14 do rUnused[i] := 0; end; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveOutline); err := SetFPos(f, FSFromStart, 0); ByteCount := SizeOf(RoiHeader); if ByteCount <> 64 then PutError('Roi header size <> 32.'); err := fswrite(f, ByteCount, @hdr); if SaveCoordinates then begin ByteCount := nCoordinates * 2; err := fswrite(f, ByteCount, ptr(xCoordinates)); ByteCount := nCoordinates * 2; err := fswrite(f, ByteCount, ptr(yCoordinates)); DataSize := nCoordinates * 4; end else DataSize := 0; if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, RefNum); exit(SaveOutline) end; err := SetEOF(f, SizeOf(RoiHeader) + DataSize); err := fsclose(f); err := GetFInfo(fname, RefNum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, RefNum, TheInfo); end; err := FlushVol(nil, RefNum); end; {with info^} end; procedure OpenOutline (fname: str255; RefNum: integer); var err, f, i: integer; count: LongInt; hdr: RoiHeader; okay: boolean; begin if Info = NoInfo then begin if (NewPicWidth * NewPicHeight) <= UndoBufSize then begin if not NewPicWindow('Untitled', NewPicWidth, NewPicHeight) then exit(OpenOutline) end else begin beep; exit(OpenOutline) end; end; KillRoi; err := fsopen(fname, RefNum, f); with info^, hdr do begin count := SizeOf(RoiHeader); err := fsread(f, count, @hdr); if rID <> 'Iout' then begin err := fsclose(f); PutError('File is corrupted.'); exit(OpenOutline) end; if (rRoiRect.right > PicRect.right) or (rRoiRect.bottom > PicRect.bottom) then begin err := fsclose(f); PutError('Image is too small for the outline.'); exit(OpenOutline) end; case rRoiType of LineRoi: begin LX1 := rX1; LY1 := rY1; LX2 := rX2; LY2 := rY2; RoiType := LineRoi; MakeRegion; SetupUndo; RoiShowing := true; end; RectRoi, OvalRoi: begin RoiType := rRoiType; RoiRect := rRoiRect; MakeRegion; SetupUndo; RoiShowing := true; end; PolygonRoi, FreehandRoi, TracedRoi: if (rNCoordinates > 2) and (rNCoordinates <= MaxCoordinates) then begin count := rNCoordinates * 2; err := fsread(f, count, ptr(xCoordinates)); count := rNCoordinates * 2; err := fsread(f, count, ptr(yCoordinates)); if CheckIO(err) = 0 then begin nCoordinates := rNCoordinates; SelectionMode := NewSelection; if rVersion >= 148 then for i := 1 to nCoordinates do with rRoiRect do begin xCoordinates^[i] := xCoordinates^[i] + left; yCoordinates^[i] := yCoordinates^[i] + top; end; MakeOutline(rRoiType); SetupUndo; end; end; end; end; err := fsclose(f); end; function GetTIFFParameters (name: str255; RefNum: integer; var HasColorMap: boolean): boolean; var err: OSErr; f: integer; DirOffset: LongInt; TiffInfo: TiffInfoRec; begin GetTIFFParameters := false; HasColorMap := false; err := fsopen(name, RefNum, f); if err <> NoErr then exit(GetTIFFParameters); if not OpenTiffHeader(f, DirOffset) then begin err := fsclose(f); exit(GetTIFFParameters) end; if not OpenTiffDirectory(f, DirOffset, TiffInfo, true) then begin err := fsclose(f); exit(GetTIFFParameters) end; with TiffInfo do begin ImportCustomWidth := width; ImportCustomHeight := height; ImportCustomOffset := OffsetToData; ImportAutoScale:=true; if BitsPerPixel = 16 then begin ImportCustomDepth := SixteenBitsUnsigned; ImportSwapBytes := IntelByteOrder; end else begin ImportCustomDepth := EightBits; ImportInvert := ZeroIsBlack; end; HasColorMap := OffsetToColorMap > 0; end; if ImportCustomDepth = EightBits then begin WhatToImport := ImportTiff; WhatToOpen := OpenTiff end else begin WhatToImport := ImportCustom; WhatToOpen := OpenCustom end; err := fsclose(f); GetTIFFParameters := true; end; procedure GetXUnits (UnitsKind: UnitsType); begin with info^ do case UnitsKind of Nanometers: xUnit := 'nm'; Micrometers: xUnit := 'µm'; Millimeters: xUnit := 'mm'; Centimeters: xUnit := 'cm'; Meters: xUnit := 'meter'; Kilometers: xUnit := 'km'; Inches: xUnit := 'inch'; feet: xUnit := 'ft'; Miles: xUnit := 'mile'; Pixels: xUnit := 'pixel'; otherwise ; end; end; procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: extended); begin with info^ do begin if xunit = 'nm' then begin UnitsKind := Nanometers; UnitsPerCm := 10000000.0; end else if xUnit = 'µm' then begin UnitsKind := Micrometers; UnitsPerCm := 10000.0; end else if xUnit = 'mm' then begin UnitsKind := Millimeters; UnitsPerCm := 10.0; end else if xUnit = 'cm' then begin UnitsKind := Centimeters; UnitsPerCm := 1.0; end else if xUnit = 'meter' then begin UnitsKind := Meters; UnitsPerCm := 0.01; end else if xUnit = 'km' then begin UnitsKind := Kilometers; UnitsPerCm := 0.00001; end else if xUnit = 'inch' then begin UnitsKind := Inches; UnitsPerCm := 0.3937; end else if xUnit = 'ft' then begin UnitsKind := feet; UnitsPerCm := 0.0328083; end else if xUnit = 'mile' then begin UnitsKind := Miles; UnitsPerCm := 0.000006213; end else if xUnit = 'pixel' then begin UnitsKind := pixels; UnitsPerCm := 0.0; SpatiallyCalibrated := false; end else begin UnitsKind := OtherUnits; UnitsPerCm := 0.0; end; end; end; function OpenMovieToolbox:boolean; var result: LongInt; err: OSErr; begin if MovieToolboxInitialized then begin OpenMovieToolbox := true; exit(OpenMovieToolbox); end; if Gestalt(gestaltQuickTime, result) <> noErr then begin ShowMessage('QuickTime Required'); OpenMovieToolbox := false; exit(OpenMovieToolbox); end; err := EnterMovies; if (err <> noErr) then begin PutMessage('QuickTime Required'); OpenMovieToolbox := false; exit(OpenMovieToolbox); end; MovieToolboxInitialized := true; OpenMovieToolbox := true; end; function OpenQuickTime (name: str255; fRefNum: integer; UseExistingLUT: boolean): boolean; {Written 3/25/94 by Eric Shelden (shelden@umich.edu)} const forwardNormalSpeed = $00010000; var RefNum, picID, hOffset, vOffset, nPICS, i: LongInt; err: OSErr; PicH: PicHandle; h: handle; MemError, Aborted: boolean; FrameRect: rect; movieResRefNum, actualResId, verb: integer; theMovie: Movie; theTrack, videoTrack: Track; theMedia: Media; inTime, trackOffset, trackEnd, sampleTime: TimeValue; mySpec: FSSpec; TheInfo: FInfo; fName: Str255; check: Boolean; trackCount, count: LongInt; mediaType, manuf: OSType; imageCTable: CTabHandle; imageDescH: ImageDescriptionHandle; pInfo: PictInfo; creatorName: str255; SavePort: GrafPtr; SaveGDevice: GDHandle; procedure Abort; begin err := CloseMovieFile(movieResRefNum); exit(OpenQuickTime); end; begin OpenQuickTime := false; check := FALSE; sampleTime := 0; if MaxBlock < MinFree then begin PutError('Insufficient memory to open QuickTime movie.'); exit(OpenQuickTime); end; ShowWatch; if not OpenMovieToolbox then exit(OpenQuickTime); err := GetFInfo(name, fRefNum, TheInfo); err := FSMakeFSSpec(fRefNum, 0, name, mySpec); err := OpenMovieFile(mySpec, movieResRefNum, fsRdPerm); if (err <> noErr) then begin PutError('QuickTime Error'); exit(OpenQuickTime); end; actualResId := DoTheRightThing; err := NewMovieFromFile(theMovie, movieResRefNum, actualResId, nil, newMovieActive, check); trackCount := GetMovieTrackCount(theMovie); videoTrack := nil; for i := 1 to trackCount do begin videoTrack := GetMovieIndTrack(theMovie, i); creatorName := ''; GetMediaHandlerDescription(GetTrackMedia(videoTrack), mediaType, creatorName, manuf); if (mediaType = 'vide') then i := trackCount + 1 else videoTrack := nil; end; if (videoTrack = nil) then begin PutError('No Movie Pictures found.'); abort; end; GetMovieBox(theMovie, FrameRect); with FrameRect do begin hOffset := left; vOffset := top; right := right - hOffset; bottom := bottom - vOffset; left := 0; top := 0; end; with FrameRect do if not NewPicWindow(name, right - left, bottom - top) then Abort; with info^ do begin revertable := false; StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then Abort; with StackInfo^ do begin SliceSpacing := 0.0; nSlices := 1; CurrentSlice := 1; PicBaseH[1] := PicBaseHandle; end; end; trackEnd := GetTrackDuration(videoTrack); trackOffset := GetTrackOffset(videoTrack); inTime := trackOffset; PicH := GetTrackPict(videoTrack, inTime); { verb := returnColorTable; err := GetPictInfo(PicH, pInfo, verb, 256, systemMethod, 0); if not UseExistingLUT then begin LoadColorTable(pInfo.theColorTable); DrawLUT; end; } with info^, Info^.StackInfo^ do begin SaveGDevice := GetGDevice; SetGDevice(osGDevice); GetPort(SavePort); SetPort(GrafPtr(osPort)); pmBackColor(WhiteIndex); EraseRect(PicRect); DrawPicture(PicH, PicRect); DisposeHandle(handle(PicH)); UpdatePicWindow; MemError := false; picID := 0; while (inTime <> -1) do begin GetTrackNextInterestingTime(videoTrack, nextTimeMediaSample, inTime, forwardNormalSpeed, inTime, sampleTime); if (inTime = -1) then Leave; picH := GetTrackPict(videoTrack, inTime); if (PicH = nil) or (ResError <> NoErr) then Leave; h := GetBigHandle(PixMapSize); if h = nil then begin if PicH <> nil then DisposeHandle(handle(picH)); MemError := true; Leave; end; nSlices := nSlices + 1; CurrentSlice := CurrentSlice + 1; PicBaseH[CurrentSlice] := h; SelectSlice(CurrentSlice); FrameRect := PicH^^.PicFrame; with FrameRect do begin right := right - hOffset; bottom := bottom - vOffset; left := left - hOffset; top := top - vOffset; end; EraseRect(PicRect); if not EqualRect(FrameRect, PicRect) then BlockMove(PicBaseH[CurrentSlice - 1]^, PicBaseH[CurrentSlice]^, PixMapSize); DrawPicture(picH, FrameRect); DisposeHandle(handle(picH)); UpdatePicWindow; SetGDevice(SaveGDevice); UpdateTitleBar; SetGDevice(osGDevice); Aborted := CommandPeriod; if Aborted then begin beep; wait(60); Leave; end; picID := picID + 1; end; {for} err := CloseMovieFile(movieResRefNum); if MemError then PutError('Not enough memory to open all images in MooV file.'); CurrentSlice := 1; SelectSlice(CurrentSlice); PictureType := PicsFile; Revertable := false; SetPort(SavePort); SetGDevice(SaveGDevice); UpdateTitleBar; UpdateWindowsMenuItem; if not MemError and not Aborted then OpenQuickTime := true; end; {with} end; procedure SaveAsQuickTime (fname: str255; fRefNum: integer); {Written by Eric A. Shelden (shelden@umich.edu) 3/23/94} const rErr = 'Error Saving QuickTime file.'; var err: OSErr; TheInfo: FInfo; replacing: boolean; rRefNum, i, SaveCS: integer; frect: rect; MinFreeRequired: LongInt; theTimeSettings: SCTemporalSettings; theRateSettings: SCDataRateSettings; theSpaceSettings: SCSpatialSettings; myComponentPtr: ptr; framesPerSecond, maxCompressedSize, curSample: longint; myResult: ComponentResult; myComponentInstance: ComponentInstance; mySpec: FSSpec; theSFR: StandardFileReply; resRefNum, resID: integer; theMovie: Movie; movieData: MovieRecord; theTrack: Track; theMedia: Media; trackFrame: Rect; theGWorld: GWorldPtr; compressedData: Handle; compressedDataptr: Ptr; imageDesc: ImageDescriptionHandle; thePixMap: PixMapHandle; check: Boolean; oldPort: CGrafPtr; oldGDeviceH: GDHandle; myTimeScale, actualTime: TimeScale; testflags: integer; begin with info^, Info^.StackInfo^ do begin if ImageSize > MinFree then MinFreeRequired := ImageSize else MinFreeRequired := MinFree; if MaxBlock < MinFreeRequired then begin PutError('Not enough memory available to save in QuickTime format.'); exit(SaveAsQuickTime); end; if not OpenMovieToolbox then exit(SaveAsQuickTime); err := GetFInfo(fname, fRefNum, TheInfo); if err = NoErr then with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'PICS') and (fdType <> 'MooV') then begin TypeMismatch(fname); exit(SaveAsQuickTime) end; err := FSDelete(fname, fRefNum); end; SaveCS := CurrentSlice; SetPort(GrafPtr(osPort)); with PicRect do SetRect(frect, 0, 0, right - left, bottom - top); ClipRect(frect); LoadLUT(ctable); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); if OldSystem then begin RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); end; testflags := 0; theGWorld := osPort; thePixMap := GetGWorldPixMap(theGWorld); check := LockPixels(thePixMap); myComponentInstance := OpenDefaultComponent('scdi', 'imag'); {myResult := SCSetTestImagePixMap(myComponentInstance, thePixMap, @frect, testflags);} myResult := SCRequestSequenceSettings(myComponentInstance); if (myResult = 1) then begin myResult := CloseComponent(myComponentInstance); exit(SaveAsQuickTime); end; if (myResult = -50) then begin myResult := CloseComponent(myComponentInstance); PutError('Invalid Parameter detected.'); exit(SaveAsQuickTime); end; myResult := SCGetInfo(myComponentInstance, 'sptl', ptr(@theSpaceSettings)); myResult := SCGetInfo(myComponentInstance, scTemporalSettingsType, ptr(@theTimeSettings)); myResult := SCGetInfo(myComponentInstance, scDataRateSettingsType, ptr(@theRateSettings)); myResult := CloseComponent(myComponentInstance); UnlockPixels(thePixMap); framesPerSecond := longint(theTimeSettings.frameRate); framesPerSecond := framesPerSecond div 65536; resRefNum := 0; theMovie := nil; ShowWatch; err := FSMakeFSSpec(fRefNum, 0, fname, mySpec); err := CreateMovieFile(mySpec, 'TVOD', $FE, createMovieFileDeleteCurFile, resRefNum, theMovie); if (err <> 0) then begin PutError(rErr); exit(SaveAsQuickTime); end; trackFrame := fRect; theTrack := NewMovieTrack(theMovie, FixRatio(trackFrame.right, 1), FixRatio(trackFrame.bottom, 1), kNoVolume); theMedia := NewTrackMedia(theTrack, 'vide', TimeScale(60), nil, ' '); err := BeginMediaEdits(theMedia); check := LockPixels(thePixMap); err := GetMaxCompressionSize(thePixMap, trackFrame, theSpaceSettings.depth, theSpaceSettings.spatialQuality, theSpaceSettings.codecType, CompressorComponent(theSpaceSettings.codec), maxCompressedSize); compressedData := NewHandle(maxCompressedSize); if (compressedData = nil) or (MemError <> 0) then begin err := EndMediaEdits(theMedia); if (theMovie <> Movie(0)) then begin err := CloseMovieFile(resRefNum); DisposeMovie(theMovie); PutError(rErr); exit(SaveAsQuickTime); end; end; MoveHHi(compressedData); HLock(compressedData); compressedDataPtr := StripAddress(compressedData^); imageDesc := ImageDescriptionHandle(NewHandle(4)); myTimeScale := 60 div framesPerSecond; GetGWorld(oldPort, oldGDeviceH); SetGWorld(theGWorld, nil); for i := 1 to nSlices do begin CurrentSlice := i; SelectSlice(CurrentSlice); err := CompressImage(thePixMap, trackFrame, theSpaceSettings.spatialQuality, theSpaceSettings.codecType, imageDesc, compressedDataPtr); err := AddMediaSample(theMedia, compressedData, 0, imageDesc^^.dataSize, myTimeScale, SampleDescriptionHandle(imageDesc), 1, 0, actualTime); end; UnlockPixels(thePixMap); SetGWorld(oldPort, oldGDeviceH); if (imageDesc <> nil) then DisposeHandle(Handle(imageDesc)); if (compressedData <> nil) then DisposeHandle(Handle(compressedData)); err := EndMediaEdits(theMedia); err := InsertMediaIntoTrack(theTrack, 0, 0, GetMediaDuration(theMedia), fixed1); err := AddMovieResource(theMovie, resRefNum, resID, fname); if (resRefNum <> 0) then err := CloseMovieFile(resRefNum); DisposeMovie(theMovie); CurrentSlice := SaveCS; SelectSlice(CurrentSlice); title := fname; PictureType := PicsFile; UpdateTitleBar; UpdateWindowsMenuItem; pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; {with} end; end.